ETO Development Tools 2/ETO Development Tools 2.iso/Tools - Objects/MacApp/MacApp CD Release/MacApp 2.0.1 (Many Libraries)/Libraries/UObject.Globals.p

Text File | 1990-10-25 | 26.8 KB | 1,086 lines | [TEXT/MPS ]

{$P}
{[a-,body+,h-,o=100,r+,rec+,t=4,u+,#+,j=20/57/1$,n-]}
{ UObject.inc1.p }
{ Copyright © 1984-1990 by Apple Computer, Inc.  All rights reserved. }

{$IFC UNDEFINED qMacApp}
{$SETC qMacApp := FALSE}
{$ENDC}

{$Push} {$IFC NOT qDebugTheDebugger}
{$W+}
{$R-}
{$Init-}
{$OV-}
{$ENDC}

{$%+  Enable '%' in identifiers}

{=====
 NOTE:
 The optimizer redirects the following procedure names
 We call the optimized names here since non-optimized dispatch
 is not supported.

%_INITOBJ  becomes %_OPTINITOBJ
%_INOBJ  becomes   %_OPTINOBJ
%_SETCLASSINDEX   becomes %_OPTSETCI
%_METHOD becomes   %_JMPTOTRAP
}

{--------------------------------------------------------------------------------------------------}

TYPE

    ClassIdTableHandle    = ^ClassIdTablePtr;
    ClassIdTablePtr     = ^ClassIdTable;
    ClassIdTable        = ARRAY [1..16000] OF ObjClassId; { Actually variable size }

{--------------------------------------------------------------------------------------------------}

VAR
    pMethDispAddr:        ProcPtr;                        {address of method dispatcher}
    pNoOfOrderedClasses: INTEGER;
    pOrderedClassIds:    ClassIdTableHandle;
    pTObjectClassID:    ObjClassId;                     {ClassID of the Root class}

    pAddNewObjectsToInspector: BOOLEAN;
    {$Push} {$Z+}
    pDisciplineMethodCalls: BOOLEAN;                    { Discipline method calls }
    pSuperClassTable:    Handle;                         {handle to superclass table}
    pDispatchErrorProc: ProcPtr;                        {Routine to handle dispatching failures}
    {$Pop}
    pInspectLinePos:    INTEGER;                        { Used to do line breaks when inspecting
                                                         fields. }
    pODFail:            ProcPtr;                        {address OD Failure Handler}
    pAllocateObjectsFromPerm: BOOLEAN;                    { Used to track whether to allocate objects
                                                         from permanent memory or not. }

{--------------------------------------------------------------------------------------------------}

PROCEDURE OrderClassIdsByName;
    FORWARD;

FUNCTION IsClassIDMemberClass(testClass: ObjClassId;
                              superClass: ObjClassId): BOOLEAN;
    EXTERNAL;

PROCEDURE %_NewMethod;
    EXTERNAL;
{ Defined in UObject.a }

PROCEDURE %_CLASSINFO;
    EXTERNAL;
{ Created by linker }

PROCEDURE %_JMPTOTRAP;
    EXTERNAL;
{ Defined in UObject.a }

PROCEDURE %_DISCIPLINEDISPATCH;
    EXTERNAL;
{ Defined in UObject.a }

PROCEDURE %_DISCIPLINEDISPATCH_PATCHPOINT;
    EXTERNAL;
{ Defined in UObject.a }

PROCEDURE AddObjectToInspector(theObject: TObject);
    EXTERNAL;
{ Defined in UInspector.p }

PROCEDURE RemoveObjectFromInspector(theObject: TObject);
    EXTERNAL;
{ Defined in UInspector.p }

PROCEDURE %_ObjError;
    FORWARD;

PROCEDURE InstallDispatcher;
    FORWARD;
{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}
{$Push} {$IFC qTrace} {$D++} {$ENDC}

FUNCTION AddNewObjectsToInspector(add: BOOLEAN): BOOLEAN;

    BEGIN
    AddNewObjectsToInspector := pAddNewObjectsToInspector;
    pAddNewObjectsToInspector := add;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}

FUNCTION AllocateObjectsFromPerm(allocateFromPerm: BOOLEAN): BOOLEAN;

    BEGIN
    AllocateObjectsFromPerm := pAllocateObjectsFromPerm;
    pAllocateObjectsFromPerm := allocateFromPerm;
    END;

{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}

FUNCTION DisciplineMethodCalls(discipline: BOOLEAN): BOOLEAN;

    BEGIN
    DisciplineMethodCalls := pDisciplineMethodCalls;
    pDisciplineMethodCalls := discipline;
    END;

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE EachClassDo(PROCEDURE DoToClass(theClass: ObjClassId));

    VAR
        tableSize:            INTEGER;
        tableOffset:        INTEGER;

    BEGIN
    tableSize := IntegerHandle(pSuperClassTable)^^;
    tableOffset := sizeof(INTEGER);
    WHILE (tableOffset < tableSize) DO
        BEGIN
        DoToClass(ObjClassId(tableOffset));
        tableOffset := tableOffset + sizeof(ObjClassId);
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE EachSubClassDo(testClass: ObjClassId;
                         PROCEDURE DoToClass(theClass: ObjClassId));

    PROCEDURE DoToCandidateClass(theClass: ObjClassId);

        BEGIN
        IF (theClass <> testClass) & IsClassIDMemberClass(theClass, testClass) THEN
            DoToClass(theClass);
        END;

    BEGIN
    EachClassDo(DoToCandidateClass);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE EachSuperClassDo(testClass: ObjClassId;
                           PROCEDURE DoToClass(theClass: ObjClassId));

    VAR
        theSuperClass:        ObjClassId;

    BEGIN
    theSuperClass := GetSuperClassID(testClass);
    WHILE theSuperClass <> kNilClass DO
        BEGIN
        DoToClass(theSuperClass);
        theSuperClass := GetSuperClassID(theSuperClass);
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE FailNonObject(obj: UNIV TObject);

    BEGIN
    IF NOT IsObject(obj) THEN
        BEGIN
        {$IFC qDebug}
        IF VerboseIsObject(obj) THEN;                    { show why }
        WrLblHexLongint('Object that failed discipline', ord(obj));
        WriteLn;
        ProgramBreak('');
        {$ENDC}
        Failure(minErr, 0);                             { ??? need to assign a message }
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}
{$Push} {$IFC qTrace} {$D++} {$ENDC}

PROCEDURE FreeIfObject(obj: TObject);

    BEGIN
    IF obj <> NIL THEN
        BEGIN
        {$IFC qDebug}
        IF NOT VerboseIsObject(obj) THEN
            ProgramBreak('In FreeIfObject: Not handed a valid object.');
        {$ENDC}
        obj.Free;
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}
{$Push} {$IFC qTrace} {$D++} {$ENDC}

PROCEDURE FreeObject(obj: TObject);

    BEGIN
    FreeIfObject(obj);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

FUNCTION GetClassID(obj: TObject): ObjClassId;

    BEGIN
    {$Ifc qDebug}
    FailNonObject(obj);
    {$Endc}
    GetClassID := ObjClassId(IntegerHandle(obj)^^);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

FUNCTION GetClassIDFromName(clName: MAName): ObjClassId;

    VAR
        high, low, index:    INTEGER;
        nameFromTable:        MAName;
        compareResult:        INTEGER;
        id:                 INTEGER;

    BEGIN
    UprMAName(clName);
    IF pNoOfOrderedClasses > 0 THEN
        BEGIN
        low := 1;
        high := pNoOfOrderedClasses;
        REPEAT
            index := BSR(low + high, 1);                { (low + high) DIV 2 }
            id := pOrderedClassIds^^[index];
            GetClassNameFromID(id, nameFromTable);
            compareResult := CompareStrings(clName, nameFromTable);
            IF compareResult = 0 THEN
                BEGIN
                GetClassIDFromName := id;
                EXIT(GetClassIDFromName);
                END;
            IF compareResult < 0 THEN
                high := index - 1
            ELSE
                low := index + 1;
        UNTIL low > high;
        END;

    {$IFC qDebug}
    ProgramBreak(Concat('Can''t find class name ', clName));
    {$ENDC qDebug}
    GetClassIDFromName := kNilClass;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

PROCEDURE GetClassNameFromID(classID: ObjClassId;
                             VAR clName: MAName);

    CONST
        kClasInfoPrefix     = 'CLASINFO.';                { 'CLASINFO.' prepended to class name }

    VAR
        namePtr:            Ptr;
        discard:            StringPtr;
        nameLength:         INTEGER;
        clNamePtr:            Ptr;
        i:                    INTEGER;

    BEGIN
    IF (classID = kNilClass) | ODD(classID) THEN
        clName := kInvalidObj
    ELSE
        BEGIN
        namePtr := Ptr(LongIntPtr(IntegerPtr(ord(pSuperClassTable^) + IntegerHandle(pSuperClassTable
                                             )^^ + classID)^ + ord(GetA5) + 2)^ + 4);

        { discard := validMacsBugSymbol(namePtr, ord(namePtr) + 256, @clName); }
        { delete(clName, 1, 9); }                        { 'CLASINFO.' }
    {!!! the above function call could conceivably return a null terminated pascal string
    that would exceed a Str255 by one byte.  If that happens we're HOSED.  The workaround
    is to have the validMacsBugSymbol call put the returned string on the stack with room
    for that last null byte.  The cost is yet another copy of the string on the stack. So…
    anticipating that no identifier names will ever ACTUALLY be 255 chars we take the simple
    path and return the name directly into the var parameter. }

        { We need all the speed we can get here, so forego the use of validMacsBugSymbol
          (it did make a difference) and do it ourselves.  This routine would be a good
          candidate for assembly }

        IF namePtr^ = $FF80 THEN                        { $FF80 instead of $80 as compile word
                                                         extends }
            BEGIN
            namePtr := Ptr(ord(namePtr) + 1);
            nameLength := namePtr^ - Length(kClasInfoPrefix);
            END
        ELSE
            nameLength := BAND(namePtr^, $7F) - Length(kClasInfoPrefix);
        clName[0] := CHR(Min(kMANameSize, nameLength));
        clNamePtr := Ptr(ord(@clName) + 1);
        namePtr := Ptr(ord(namePtr) + Length(kClasInfoPrefix) + 1);
        FOR i := 1 TO ord(clName[0]) DO
            BEGIN
            clNamePtr^ := namePtr^;
            clNamePtr := Ptr(ord(clNamePtr) + 1);
            namePtr := Ptr(ord(namePtr) + 1);
            END;

        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

FUNCTION GetClassSizeFromId(classID: ObjClassId): Size;

    BEGIN
    GetClassSizeFromId := IntegerPtr(LongIntPtr(IntegerPtr(ord(pSuperClassTable^) +
                                                           IntegerHandle(pSuperClassTable)^^ +
                                                           classID)^ + ord(GetA5) + 2)^ +
                          2)^;

    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

FUNCTION GetSuperClassID(objID: ObjClassId): ObjClassId;

    BEGIN
    IF objID <> kNilClass THEN
        GetSuperClassID := ObjClassIDPtr(ord(pSuperClassTable^) + objID)^
    ELSE
        GetSuperClassID := kNilClass;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MADebug}

PROCEDURE IDUobject;

    BEGIN
    WRITELN('Uobject of 14 Feb 90 (Valentine''s Day), Compiled on ', COMPDATE, ' @ ', COMPTIME);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

FUNCTION GetSuperClassTableHandle: Handle;

    BEGIN
    {$Push} {$B-}                                        { Force Jump Table relative }
    GetSuperClassTableHandle := Handle(ord(@%_CLASSINFO) + 2); { skip jmp instruction to make PHONY
                                                                handle }
    {$Pop}
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MAInit}

PROCEDURE InitUObject;

    BEGIN
    {$IFC qInspector}
    pAddNewObjectsToInspector := TRUE;
    {$EndC}
    {$IFC qDebug}
    pDisciplineMethodCalls := TRUE;
    {$ENDC qDebug}

    pAllocateObjectsFromPerm := TRUE;

    InstallDispatcher;

    OrderClassIdsByName;
    pTObjectClassID := GetClassIDFromName('TObject');
    END;

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MADebug}

PROCEDURE InspectField(fieldName: Str255;
                       fieldAddr: Ptr;
                       fieldType: INTEGER);

    VAR
        s:                    Str255;
        x:                    INTEGER;

    BEGIN
    IF fieldType <> bClass THEN
        BEGIN
        FieldToString(fieldAddr, fieldType, s);
        x := Length(fieldName) + 1 + Length(s);
        {??? maybe a better solution would be to let the transcript do it's own word breaks}
        {$IFC qDebug}
        IF pInspectLinePos + x + 2 >= DebugTranscriptWidth THEN
            BEGIN
            WriteLn;
            pInspectLinePos := 0;
            END
        ELSE IF pInspectLinePos <> 0 THEN                { If not at the start of a line }
            BEGIN
            WRITE('  ');
            pInspectLinePos := pInspectLinePos + 2;
            END;
        {$EndC}
        WRITE(fieldName, '=', s);
        pInspectLinePos := pInspectLinePos + x;
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MADebug}

PROCEDURE InspectObject(obj: TObject);

    VAR
        oldState:            BOOLEAN;

    BEGIN
    IF VerboseIsObject(obj) THEN
        BEGIN
        oldState := obj.Lock(TRUE);
        obj.Inspect;
        WriteLn;
        oldState := obj.Lock(oldState);
        END
    ELSE
        BEGIN
        WritePtr(obj);
        WriteLn(' is not a TObject!');
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}

FUNCTION IsObject(obj: UNIV TObject): BOOLEAN;
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

    BEGIN

    IF IsHandle(obj)
    { Test for handle not purged since we don't allow purgeable objects (??? yet?, ever?) }
       & (Ptr(StripLong(Handle(obj)^)) <> NIL)
    { Test objecthood }
       & IsClassIDMemberClass(ObjClassIDHandle(obj)^^, pTObjectClassID) &
       (GetHandleSize(Handle(obj)) >= GetClassSizeFromId(ObjClassIDHandle(obj)^^)) THEN
        IsObject := TRUE
    ELSE
        IsObject := FALSE;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

FUNCTION IsMemberClassID(obj: TObject;
                         objID: ObjClassId): BOOLEAN;

    BEGIN
    {$IFC qDebug}
    FailNonObject(obj);
    {$ENDC}
    IF IsObject(obj) THEN
        IsMemberClassID := IsClassIDMemberClass(ObjClassIDHandle(obj)^^, objID)
    ELSE
        IsMemberClassID := FALSE;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MAObjectRes}
{$Push} {$IFC qTrace} {$D+} {$ENDC}

FUNCTION MakeNewInstance(classID: ObjClassId): TObject;
{ makes objects for "new" calls.  Internal use only. }

{$IFC qDebug}

    CONST
        initVal             = $F1F1;                    { guaranteed to be odd at all byte
                                                         boundaries }
        {$ENDC}

    VAR
        {$IFC qDebug}
        i:                    Size;
        p:                    IntegerPtr;
        {$ENDC}

        itsSize:            Size;
        obj:                TObject;

    BEGIN
    IF classID <> kNilClass THEN
        BEGIN
        itsSize := GetClassSizeFromId(classID);
        IF qMacApp & pAllocateObjectsFromPerm THEN
            Handle(obj) := NewPermHandle(itsSize)
        ELSE
            Handle(obj) := NewHandle(itsSize);

        IF obj <> NIL THEN
            BEGIN

            {$IFC qDebug}
            {Initialize the object to $F1F1F1F1...}
            p := IntegerPtr(Handle(obj)^);
            FOR i := 1 TO itsSize DIV 2 DO
                BEGIN
                p^ := initVal;
                p := IntegerPtr(ord(p) + 2);
                END;
            {$ENDC}

            { Install class ID into object }
            ObjClassIDHandle(obj)^^ := classID;

            {$IFC qInspector}
            IF pAddNewObjectsToInspector THEN
                AddObjectToInspector(obj);
            {$ENDC}
            END;
        MakeNewInstance := obj;
        END
    ELSE
        MakeNewInstance := NIL;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

FUNCTION NewObjectByClassId(classID: ObjClassId): TObject;

{$IFC qDebug}

    VAR
        s:                    MAName;
        className:            MAName;
        {$ENDC}

    BEGIN
    {$IFC qDebug}
    IF gAskAboutAlloc & CanReadLn THEN
        BEGIN

        GetCallersMethodName(s);
        GetClassNameFromID(classID, className);
        WriteLn('Within ', s, ', trying to make a ''', className, '''.');

        IF ReadYesNo('     Return NIL (Y or N) [N]? ') THEN
            BEGIN
            NewObjectByClassId := NIL;
            EXIT(NewObjectByClassId);
            END;
        END;
    {$ENDC qDebug}

    NewObjectByClassId := MakeNewInstance(classID);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

FUNCTION NewObjectByClassName(className: MAName): TObject;

    VAR
        classID:            ObjClassId;
        {$IFC qDebug}
        s:                    MAName;
        {$ENDC}

    BEGIN
    {$IFC qDebug}
    IF gAskAboutAlloc & CanReadLn THEN
        BEGIN

        GetCallersMethodName(s);
        WriteLn('Within ', s, ', trying to make a ''', className, '''.');

        IF ReadYesNo('     Return NIL (Y or N) [N]? ') THEN
            BEGIN
            NewObjectByClassName := NIL;
            EXIT(NewObjectByClassName);
            END;
        END;
    {$ENDC qDebug}

    classID := GetClassIDFromName(className);
    NewObjectByClassName := MakeNewInstance(classID);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE OBJFail(error: INTEGER);

    BEGIN
    {$IFC qDebug}

    CASE error OF
        kFailCoercion:
            ProgramBreak('Object type coercion error.');
        kFailMethNotFound:
            ProgramBreak('Method not found');
        OTHERWISE
            BEGIN
            WriteLn('Failure code: ', error);
            ProgramBreak('Object runtime failure. See UObject.p.');
            END;
    END;
    {$ENDC}
    {$IFC qMacApp}
    Failure(minErr, 0);                                 { ??? need to assign a message }
    {$ELSEC}
    { ??? Should we do anything if not for MacApp? }
    {$ENDC}
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$W+}
{$R-}
{$OV-}
{$S MAObjectRes}

PROCEDURE OrderClassIdsByName;

    VAR
        startOfClassList, endOfClassList: IntegerPtr;
        aClassName:         MAName;
        nameFromTable:        MAName;
        high, low, index:    INTEGER;
        id:                 ObjClassId;
        tableSize:            INTEGER;

    BEGIN
    pNoOfOrderedClasses := 0;

 { pSuperClassTable is a handle to the combined superclass & classlist table.  The integer at
 pSuperClassTable^^ gives the size of the superclass table. The classlist table immediately
 follows the superclass table and the first integer in the classlist table gives the
 size of the classlist table. }

    startOfClassList := IntegerPtr(ord(pSuperClassTable^) + IntegerHandle(pSuperClassTable)^^);
    endOfClassList := IntegerPtr(ord(startOfClassList) + startOfClassList^);

    tableSize := ord(endOfClassList) - ord(startOfClassList);

    {$IFC qMacApp}                                        {We can't call failure if not for MacApp }
    pOrderedClassIds := ClassIdTableHandle(NewPermHandle(tableSize));
    FailNIL(pOrderedClassIds);
    {$ELSEC}
    pOrderedClassIds := ClassIdTableHandle(NewHandle(tableSize));
    IF pOrderedClassIds = NIL THEN
        EXIT(OrderClassIdsByName);                        { Caller should check for NIL }
    {$ENDC}

    startOfClassList := IntegerPtr(ord(startOfClassList) + 2);
    id := 2;
    WHILE (ord(startOfClassList) < ord(endOfClassList)) DO
        BEGIN
        IF startOfClassList^ <> 0 THEN
            BEGIN
            GetClassNameFromID(ObjClassId(id), aClassName);

            IF pNoOfOrderedClasses = 0 THEN
                index := 1
            ELSE
                BEGIN
                low := 1;
                high := pNoOfOrderedClasses;
                REPEAT
                    index := BSR(low + high, 1);        { (low + high) DIV 2 }
                    GetClassNameFromID(pOrderedClassIds^^[index], nameFromTable);
                    IF aClassName < nameFromTable THEN
                        high := index - 1
                    ELSE
                        BEGIN
                        low := index + 1;
                        index := index + 1;
                        END;
                UNTIL low > high;

                {$IFC qDebug}
                IF pNoOfOrderedClasses >= tableSize DIV 2 THEN
                    ProgramBreak('Ordered class id table exceeded.');
                {$ENDC}
                END;
            IF index <= pNoOfOrderedClasses THEN
                BlockMove(@pOrderedClassIds^^[index], @pOrderedClassIds^^[index + 1],
                          (pNoOfOrderedClasses - index + 1) * sizeof(ObjClassId));
            pOrderedClassIds^^[index] := id;
            pNoOfOrderedClasses := pNoOfOrderedClasses + 1;
            END;

        startOfClassList := IntegerPtr(ord(startOfClassList) + 2);
        id := id + 2;
        END;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S MADebug}

FUNCTION VerboseIsObject(obj: UNIV TObject): BOOLEAN;

    VAR
        className:            MAName;
        classSize:            Size;
        instSize:            Size;

    BEGIN
    VerboseIsObject := FALSE;
    IF VerboseIsHandle(obj) THEN
    { Test for handle not purged since we don't allow purgeable objects (??? yet?, ever?) }
        IF (Ptr(StripLong(Handle(obj)^)) = NIL) THEN
            WriteLn('  That handle appears to be purged.')
        ELSE IF NOT IsClassIDMemberClass(ObjClassIDHandle(obj)^^, pTObjectClassID) THEN
            WriteLn('  That handle is not a subclass of TObject.')
        ELSE IF (GetHandleSize(Handle(obj)) < GetClassSizeFromId(GetClassID(obj))) THEN
            BEGIN
            GetClassNameFromID(GetClassID(obj), className);
            classSize := GetClassSizeFromId(GetClassID(obj));
            instSize := GetHandleSize(Handle(obj));
            WriteLn('  That handle at: ', instSize: 1, ' bytes is smaller than a ', className,
                    ' is supposed to be at: ', classSize: 1, ' bytes.');
            END
        ELSE
            VerboseIsObject := TRUE;
    END;

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MADebug}

PROCEDURE WrLblField(fieldName: Str255;
                     fieldAddr: Ptr;
                     fieldType: INTEGER);

    BEGIN
    pInspectLinePos := 0;
    InspectField(fieldName, fieldAddr, fieldType);
    pInspectLinePos := 0;
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S %_MethTables}

PROCEDURE InstallDispatcher;
{ LOW LEVEL one time initialization. Must be in same segment as dispatcher. }

    TYPE
        JmpToTrapPatchPtr    = ^JmpToTrapPatch;
        JmpToTrapPatch        = RECORD
            Jmp:                INTEGER;                { jmp instruction }
            Routine:            ProcPtr;                { address to jump to }
            END;

    VAR
        aJmpToTrapPatchPtr: JmpToTrapPatchPtr;

    BEGIN
    { The new method dispatcher provided with MacApp is enough faster that it is even worth using
    instead of the ROM based dispatcher. }

    pMethDispAddr := @%_NewMethod;
    {$IFC qDebug}
    pODFail := @FailNonObject;
    {$ENDC}

{ NOTE =================================================
 the following is a real slimedog trick but since we are
 after performance in this bottleneck we'll do it anyway.
 since it saves a memory fetch for each dispatch.
 Don't need to flush the cache here.
 }
    aJmpToTrapPatchPtr := @%_JMPTOTRAP;
    WITH aJmpToTrapPatchPtr^ DO
        BEGIN
        Jmp := $4EF9;                                    { JMP #Routine }
        {$IFC qDebug}
        Routine := @%_DISCIPLINEDISPATCH;
        {$ELSEC}
        Routine := pMethDispAddr;
        {$ENDC}
        END;

    {$IFC qDebug}
    aJmpToTrapPatchPtr := @%_DISCIPLINEDISPATCH_PATCHPOINT;
    WITH aJmpToTrapPatchPtr^ DO
        BEGIN
        Jmp := $4EF9;                                    { JMP #Routine }
        Routine := pMethDispAddr;
        END;
    {$ENDC}

    { Don't forget the superclass table and the error handler }
    pSuperClassTable := GetSuperClassTableHandle;
    pDispatchErrorProc := @%_ObjError;

    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_INITOBJ;
{ LOW LEVEL required to satisfy fussy linker.  Even though the optimizer
 redirects these entry points they must at least be present. }

    BEGIN
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_INOBJ;
{ LOW LEVEL required to satisfy fussy linker.  Even though the optimizer
 redirects these entry points they must at least be present. }

    BEGIN
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

FUNCTION %_OBCHK(obj: TObject;
                 jumpTablePtr: Ptr): TObject;

{ LOW LEVEL routine called at run time verify object coercions.  It returns its obj
parameter if the parameter is nil or passes the membership test.  Otherwise it calls
ObjFail.  }

    BEGIN
    {$IFC qDebug}
    IF (obj <> NIL) THEN
        FailNonObject(obj);
    {$ENDC}
    %_OBCHK := obj;
    IF (obj <> NIL) & (NOT IsClassIDMemberClass(ObjClassIDHandle(obj)^^,
                                                ObjClassIDHandle(jumpTablePtr)^^)) THEN
        OBJFail(kFailCoercion);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D++} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_OBDISP(obj: TObject);
{ LOW LEVEL routine called by DISPOSE(<object>); }

    BEGIN
    {$Ifc qDebug}
    FailNonObject(obj);
    {$Endc}

    {$IFC qInspector}
    RemoveObjectFromInspector(obj);
    {$ENDC}

    Handle(obj) := DisposeIfHandle(obj);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}

{$Push} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_ObjError;
{ LOW LEVEL Error routine that ROM method dispatch routine jumps to if method not found
  Address of this routine is stuffed at lomem location MAErrProc at startup }

    BEGIN
    OBJFail(kFailMethNotFound);                         { Method Not Found }
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D++} {$ENDC}

{$S MAObjectRes}

PROCEDURE %_OBNEW(VAR obj: TObject;
                  jumpTablePtr: Ptr;
                  itsSize: INTEGER);                    { !!! itsSize is unused }
{ LOW LEVEL routine called by NEW(<object>); }

    VAR
        {$IFC qDebug}
        n:                    MAName;
        s:                    MAName;
        {$ENDC}
        classID:            ObjClassId;

    BEGIN
    classID := ObjClassIDHandle(jumpTablePtr)^^;
    {$IFC qDebug}
    IF gAskAboutAlloc & CanReadLn THEN
        BEGIN

        GetCallersMethodName(s);
        GetClassNameFromID(classID, n);
        WriteLn('Within ', s, ', trying to make a ''', n, '''.');

        IF ReadYesNo('     Return NIL (Y or N) [N]? ') THEN
            BEGIN
            obj := NIL;
            EXIT(%_OBNEW);
            END;
        END;
    {$ENDC qDebug}

    obj := MakeNewInstance(classID);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}

{$S MAObjectRes}

FUNCTION %_OPTINOBJ(obj: TObject;
                    jumpTablePtr: Ptr): BOOLEAN;
{ LOW LEVEL called to perform MEMBER function }

    BEGIN
    {$IFC qDebug}
    IF (obj <> NIL) THEN
        FailNonObject(obj);
    {$ENDC}
    %_OPTINOBJ := (obj <> NIL) & IsClassIDMemberClass(ObjClassIDHandle(obj)^^,
                                                      ObjClassIDHandle(jumpTablePtr)^^);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_OptInitObj;
{ LOW LEVEL Not Used.  Must be present however to satisfy linker }

    BEGIN
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_OptSetCI;
{ LOW LEVEL Not Used.  Must be present however to satisfy linker }

    BEGIN
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S MAObjectRes}

PROCEDURE %_METHOD;
{ LOW LEVEL required to satisfy fussy linker.  Even though the optimizer
 redirects these entry points they must at least be present. }

    BEGIN
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$Push} {$Z+} {$IFC qTrace} {$D+} {$ENDC}
{$S Main}                    { Must actually be in "Main" since it is called in UNIT setup by Pascal }

PROCEDURE %_PGM1;
{ LOW LEVEL The Pascal compiler generates code to call this procedure automatically, before
initializing the units and starting the application's main program.  This function must always
work on 64K ROMs. }

    BEGIN
    END;
{$Pop}

{$Pop}